(FILECREATED "16-SEP-73 12:32:45" RECORD.TEM)


  (LISPXPRINT (QUOTE RECORDVARS)
              T)
  [RPAQQ
    RECORDVARS
    ((FNS TYPERECORD RECORD RECDO RECCOMPOSE0 'CAR 'CDR 'CONS 
          RECCOMPOSE1 RECCOMPOSE2 RECCOMPOSE4 MAKECROPFN1 CLISPLOOKUP 
          FIELDSIN /PUTDTST DWIMUSERFN MAKERPLAC SETPACK MAKESETFN)
     (PROP CLISPWORD CREATE create USING using)
     (PROP MACRO CREATE USING create using)
     (PROP PRETTYTYPE RECORDS)
     (ADDVARS
       (SYSPROPS RECORD RCROPS RECDEFAULT)
       (PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
       (CLISPRETTYWORDS create CREATE USING using)
       (CLISPWORDS CREATE create USING using)
       [PRETTYMACROS
         (RECORDS X
                  (E (MAPC (QUOTE X)
                           (FUNCTION
                             (LAMBDA (Z)
                                     (PRINT (LIST (QUOTE RECORD)
                                                  Z
                                                  (GETP Z (QUOTE RECORD]
       (GLOBALVARS CRLIST USERRECORDS CHANGEDRECLST RECORDWORDSSPLST))
     (VARS (CHANGEDRECLST NIL)
           CRLIST
           (USERRECORDS NIL)
           (DWIMUSERFN T)
           RECORDWORDSSPLST)
     (BLOCKS (MAKERPLAC MAKERPLAC CLISPLOOKUP)
             (CREATEBLOCK RECCOMPOSE0 RECCOMPOSE1 FIELDSIN RECCOMPOSE2 
                          RECCOMPOSE4 'CAR 'CDR 'CONS (ENTRIES 
                                                        RECCOMPOSE0)
                          (LOCALFREEVARS L FROMVAR))
             (RECORDBLOCK RECORD TYPERECORD RECDO /PUTDTST MAKECROPFN1
                          (ENTRIES RECORD TYPERECORD)
                          (BLKAPPLYFNS RECORD]
(DEFINEQ

(TYPERECORD
  [NLAMBDA (NAME FIELD)
    (BLKAPPLY* RECORD NAME (CONS NAME FIELD))
    [/PUTDTST (SETQ FIELD (PACK (LIST NAME "?")))
              (LIST (QUOTE LAMBDA)
                    (QUOTE (RECORDVAR))
                    (LIST (QUOTE EQ)
                          (QUOTE (CAR RECORDVAR))
                          (KWOTE NAME]
    (/PUT FIELD (QUOTE MACRO)
          (CDR (GETD FIELD)))
    NAME])

(RECORD
  [NLAMBDA (NAME FIELD)
    (COND
      [(LISTP NAME)
        (COND
          ((NULL FIELD)
            (SETQ FIELD NAME)
            (SETQ NAME NIL))
          (T (ERROR "Invalid record name" NAME]
      ((NLISTP FIELD)
        (OR (SETQ FIELD (GETP NAME (QUOTE RECORD)))
            (ERROR "Invalid record" FIELD T)))
      (T (COND
           ((AND (GETP NAME (QUOTE RECORD))
                 (NULL DFNFLG))
             (LISPXPRINT (CONS NAME (QUOTE (redeclared)))
                         T)))
         [COND
           (DWIMFLG (SETQ USERRECORDS (CONS NAME USERRECORDS))
                    (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
                                                   (QUOTE USERRECORDS)
                                                   (CDR USERRECORDS]
         [COND
           (FILEPKGFLG [FRPLACA (QUOTE CHANGEDRECLST)
                                (CONS NAME (CAR (QUOTE CHANGEDRECLST]
                       (AND LISPXHIST
                            (UNDOSAVE (LIST (QUOTE /RPLACA)
                                            (CAR (QUOTE CHANGEDRECLST)))
                                      LISPXHIST]
         (/PUT NAME (QUOTE RECORD)
               FIELD)))
    (PROG (TEM)
          (RECDO (COND
                   ((EQ NAME (CAR FIELD))
                     (CONS NIL (CDR FIELD)))
                   (T FIELD))
                 NIL))
    NAME])

(RECDO
  [LAMBDA (FORMAT RCROPS)
    (COND
      ((NULL FORMAT)
        NIL)
      ((LISTP FORMAT)
        (RECDO (CAR FORMAT)
               (CONS (QUOTE A)
                     RCROPS))
        (RECDO (CDR FORMAT)
               (CONS (QUOTE D)
                     RCROPS)))
      ((LITATOM FORMAT)
        (PROG (TEM (CROPFN (LIST (QUOTE (RECORDFIELDVAR))
                                 (MAKECROPFN1 RCROPS)))
                   TEM2)
              (/PUTDTST FORMAT (OR (AND (NLISTP (CADADR CROPFN))
                                        (GETD (CAADR CROPFN)))
                                   (CONS (QUOTE LAMBDA)
                                         CROPFN)))
              (/PUT FORMAT (QUOTE MACRO)
                    CROPFN)
              [/PUT FORMAT (QUOTE ACCESSFN)
                    (CONS FORMAT (SETQ TEM (PACK (LIST "SET." FORMAT]
              (MAKESETFN TEM FORMAT CROPFN)))
      (T (ERROR "Invalid record field" FORMAT])

(RECCOMPOSE0
  [LAMBDA (COMPOSESTATEMENT)
    (PROG ((L COMPOSESTATEMENT)
           FIELDS VAR DEF FROMVAR RECFIELDS !RECORDFLG)

          (* Constructs a composition of FIELD using things 
          from L -
          First L must be split up into things in field)


      LP  (COND
            ((EQ [CAR (SETQ TEM (GETP (CAR L)
                                      (QUOTE CLISPWORD]
                 (QUOTE RECORDWORD))
              [SETQ TEM (COND
                  ((NLISTP (CDR TEM))
                    (CDR TEM))
                  (T (CADDR TEM]
              [COND
                ((FMEMB TEM (QUOTE (CREATE create)))
                                                (* This allows for 
                                                synonyms)
                  (SETQ FIELDS (OR (GETP (CADR L)
                                         (QUOTE RECORD))
                                   (GETP (FIXSPELL (CADR L)
                                                   70 USERRECORDS "->"
                                                   (CDR L)
                                                   NIL T)
                                         (QUOTE RECORD))
                                   (ERROR (CADR L)
                                          "not a record")))
                                                (* Get the record 
                                                fields)
                  [SETQ !RECORDFLG (COND
                      ((EQ (CAR FIELDS)
                           (CADR L))
                        (CADR L]
                  (SETQ L (CDDR L)))
                ((FMEMB TEM (QUOTE USING using))
                  (DWIMIFY1B (CDR L)
                             COMPOSESTATEMENT
                             (CDR L)
                             T T FAULTFN)
                  (SETQ FROMVAR (CADR L))
                  (SETQ L (CDDR L]
              (GO LP)))
          (AND (NOT (AND FROMVAR FIELDS))
               (FIXSPELL (CAR L)
                         70 RECORDWORDSSPLST "->" L NIL T)
               (GO LP))
          (SETQ RECFIELDS (FIELDSIN FIELDS))
          (DWIMIFY1B L COMPOSESTATEMENT L T NIL FAULTFN)
          (for EXPR in L
             do (SELECTQ (CAR EXPR)
                         [(SETQ SETQQ SAVESETQ SAVESETQQ)
                           (OR (FMEMB (CADR EXPR)
                                      RECFIELDS)
                               (FIXSPELL (CADR EXPR)
                                         70 RECFIELDS "->"
                                         (CDR EXPR)
                                         NIL T)
                               (ERROR "Bad field name" (CADR EXPR]
                         (ERROR "form not fieldname←value in" 
                                COMPOSESTATEMENT)))
          [SETQ DEF (RECCOMPOSE1 FIELDS (AND FROMVAR
                                             (COND
                                               ((LISTP FROMVAR)
                                                 (SETQQ VAR CREATEVAR))
                                               (!RECORDFLG
                                                 ('CDR FROMVAR))
                                               (T FROMVAR]
          [COND
            (VAR (SETQ DEF (LIST (LIST (QUOTE LAMBDA)
                                       (LIST VAR)
                                       DEF)
                                 (COND
                                   (!RECORDFLG ('CDR FROMVAR))
                                   (T FROMVAR]
          (SETQ TEM (FOR EXPR IN L JOIN (SETPACK EXPR)))
          (/RPLNODE L (CAR TEM)
                    (CDR TEM))
          (RETURN (COND
                    (!RECORDFLG ('CONS (KWOTE !RECORDFLG)
                                       DEF))
                    (T DEF])

('CAR
  [LAMBDA (X)
    (PROG (TEM)
          (COND
            ([NULL (SETQ TEM (CADR (FASSOC (CAR X)
                                           CRLIST]
              (LIST (QUOTE CAR)
                    X))
            (T (LIST TEM (CADR X])

('CDR
  [LAMBDA (X)
    (PROG (TEM)
          (COND
            ([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
                                            CRLIST]
              (LIST (QUOTE CDR)
                    X))
            (T (LIST TEM (CADR X])

('CONS
  [LAMBDA (CARPART CDRPART)
    (COND
      [(OR (EQ (CAR CDRPART)
               (QUOTE LIST))
           (NOT (CAR CDRPART)))
        (CONS (QUOTE LIST)
              (CONS CARPART (CDR CDRPART]
      (T (LIST (QUOTE CONS)
               CARPART CDRPART])

(RECCOMPOSE1
  [LAMBDA (FIELD DEF)
    (PROG (K)
          (COND
            ((SETQ K (RECCOMPOSE2 FIELD DEF))
              (CAR K))
            (FROMVAR DEF)
            (T (RECCOMPOSE4 FIELD])

(RECCOMPOSE2
  [LAMBDA (FIELD DEF)

          (* Constructs the composition of FIELD , returning 
          NIL if none of the fields in FIELD are mentioned in 
          L -
          and <consexpression> otherwise)


    (COND
      ((NULL FIELD)
        NIL)
      [(ATOM FIELD)
        (PROG (TEM)
              (AND [SETQ TEM (SOME L (FUNCTION (LAMBDA (X)
                                       (EQ (CADR X)
                                           FIELD]
                   (SELECTQ (CAAR TEM)
                            [(SAVESETQQ SETQQ)
                              (LIST (KWOTE (CADDR (CAR TEM]
                            (CDDAR TEM]
      (T (PROG [(KD (RECCOMPOSE2 (CDR FIELD)
                                 ('CDR DEF)))
                (KA (RECCOMPOSE2 (CAR FIELD)
                                 ('CAR DEF]
               (COND
                 ((AND (NULL KA)
                       (NULL KD))
                   (RETURN NIL)))
               (RETURN (LIST ('CONS [COND
                                      (KA (CAR KA))
                                      (FROMVAR ('CAR DEF))
                                      (T (RECCOMPOSE4 (CAR FIELD]
                                    (COND
                                      (KD (CAR KD))
                                      (FROMVAR ('CDR DEF))
                                      (T (RECCOMPOSE4 (CDR FIELD])

(RECCOMPOSE4
  [LAMBDA (FIELD)
    (COND
      ((NULL FIELD)
        NIL)
      [(ATOM FIELD)
        ([LAMBDA (X)
            (COND
              (X (KWOTE X]
          (GETP FIELD (QUOTE RECDEFAULT]
      (T ('CONS (RECCOMPOSE4 (CAR FIELD))
                (RECCOMPOSE4 (CDR FIELD])

(MAKECROPFN1
  [LAMBDA (RCROPS)
    (COND
      ((NULL RCROPS)
        (QUOTE RECORDFIELDVAR))
      ((NULL (CDDDDR RCROPS))
        (LIST [PACK (CONS (QUOTE C)
                          (APPEND RCROPS (QUOTE (R]
              (QUOTE RECORDFIELDVAR)))
      (T (LIST (PACK (LIST (QUOTE C)
                           (CAR RCROPS)
                           (CADR RCROPS)
                           (CADDR RCROPS)
                           (CADDDR RCROPS)
                           (QUOTE R)))
               (MAKECROPFN1 (CDDDDR RCROPS])

(CLISPLOOKUP
  [LAMBDA (FN VAR1 VAR2 LISPFN)

          (* In most cases, it is not necessary to do a full 
          lookup. This is q uick an dirty check inside of the 
          block to avoid calling CLISPLOOKUP0 It will work 
          whenever there are no declarations.
          Only difference between this and CLISPIFYLOOKUP is 
          that is that we already have performed 
          (GETP FN 'LISPFN))


    (PROG (CLASS TEM)
          (RETURN (COND
                    ([OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
                              (EQ (CAR (SETQ TEM (CADDR EXPR)))
                                  (QUOTE *))
                              (EQ (CADR TEM)
                                  (QUOTE DECLARATIONS:))
                              (SETQ TEM (CDDDR TEM)))
                         (AND (EQ (CAR TEM)
                                  (QUOTE CLISP:))
                              (SETQ TEM (CLISPDEC0 TEM FAULTFN]
                                                (* must do full lookup.)
                      (CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS))
                    (T (OR LISPFN FN])

(FIELDSIN
  [LAMBDA (X)
    (COND
      ((NULL X)
        NIL)
      ((NLISTP X)
        (LIST X))
      (T (NCONC (FIELDSIN (CAR X))
                (FIELDSIN (CDR X])

(/PUTDTST
  [LAMBDA (ATM DEF)
    [COND
      ((FGETD ATM)
        (VIRGINFN ATM T)
        (COND
          ((NULL DFNFLG)
            (LISPXPRINT (CONS ATM (QUOTE (redefined)))
                        T)
            (SAVEDEF ATM]
    (COND
      (DWIMFLG (ADDSPELL ATM)))
    (/PUTD ATM DEF])

(DWIMUSERFN
  [LAMBDA NIL
    (AND (NOT FAULTAPPLYFLG)
         (LISTP FAULTX)
         (LITATOM (CAR FAULTX))
         (NOT (FGETD (CAR FAULTX)))
         (PROG [(MACVAL (GETP (CAR FAULTX)
                              (QUOTE MACRO]
               (AND MACVAL (NOT (EDITFINDP MACVAL (QUOTE ASSEMBLE)))
                    [CLISPTRAN FAULTX
                               (COND
                                 ((FMEMB (CAR MACVAL)
                                         (QUOTE [LAMBDA NLAMBDA]))
                                   (CONS MACVAL (CDR FAULTX)))
                                 ((AND (CAR MACVAL)
                                       (ATOM (CAR MACVAL)))
                                   (EVALA (CADR MACVAL)
                                          (LIST (CONS (CAR MACVAL)
                                                      (CDR FAULTX)))
                                          (QUOTE INTERNAL)))
                                 (T (SUBPAIR (CAR MACVAL)
                                             (CDR FAULTX)
                                             (CADR MACVAL]
                    (RETURN FAULTX])

(MAKERPLAC
  [LAMBDA (X DEF FN)
    (SETQ DEF (SUBST (CAR X)
                     (QUOTE RECORDFIELDVAR)
                     DEF))
    (CONS (CLISPLOOKUP FN DEF (CADR X)
                       (GETP FN (QUOTE LISPFN)))
          (CONS DEF (CDR X])

(SETPACK
  [LAMBDA (SETQEXPRESSION)                      (* returns the list of 
                                                what the setq clispifies
                                                to)

          (* (SETQ X FOO) X←FOO (SETQ X 
          (FOO)) X← (FOO) (SETQQ X FOO) X←'FOO 
          (SETQQ X (FOO)) X←'FOO)


    (COND
      [(LISTP (CADDR SETQEXPRESSION))
        (LIST (PACK (CONS (CADR SETQEXPRESSION)
                          (CONS (QUOTE ←)
                                (SELECTQ (CAR SETQEXPRESSION)
                                         ((SETQQ SAVESETQQ)
                                           (QUOTE '))
                                         NIL]
      (T (LIST (PACK (CONS (CADR SETQEXPRESSION)
                           (CONS (QUOTE ←)
                                 (SELECTQ (CAR SETQEXPRESSION)
                                          ((SETQQ SAVESETQQ)
                                            (CONS (QUOTE ')
                                                  (CDDR SETQEXPRESSION))
                                            )
                                          (CDDR SETQEXPRESSION])

(MAKESETFN
  [LAMBDA (TEM FORMAT CROPFN)
    (PROG (TEM2)
          (/PUT TEM (QUOTE ACCESSFN)
                FORMAT)
          (SETQ TEM2 (FASSOC (CAADR CROPFN)
                             CRLIST))
          (/PUTDTST
            TEM
            (COND
              [[AND (FMEMB (CAADR CROPFN)
                           (QUOTE (CAR CDR)))
                    (NLISTP (CADR (CADR CROPFN]
                (GETD (SELECTQ (CAADR CROPFN)
                               (CAR (QUOTE RPLACA))
                               (CDR (QUOTE RPLACD))
                               (HELP]
              (T (LIST (QUOTE LAMDA)
                       (QUOTE (X VALUE))
                       (MAKERPLAC (QUOTE (X VALUE))
                                  (SELECTQ (CAADR CROPFN)
                                           ((CDR CAR)
                                             (CADADR CROPFN))
                                           (LIST (CAR (CDDDDR TEM2))
                                                 (CADADR CROPFN)))
                                  (SELECTQ (CADDDR TEM2)
                                           (CAR (QUOTE RPLACA))
                                           (CDR (QUOTE RPLACD))
                                           (HELP])
)
(DEFLIST(QUOTE(
  (CREATE (RECORDWORD . create))
  (create (RECORDWORD . create))
  (USING (RECORDWORD . using))
  (using (RECORDWORD . using))
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
  [CREATE (X (RECCOMPOSE0 (CONS (QUOTE CREATE)
                                X]
  [USING (X (RECCOMPOSE0 (CONS (QUOTE USING)
                               X]
  [create (X (RECCOMPOSE0 (CONS (QUOTE CREATE)
                                X]
  [using (X (RECCOMPOSE0 (CONS (QUOTE USING)
                               X]
))(QUOTE MACRO))

(DEFLIST(QUOTE(
  [RECORDS (LAMBDA (X Y)
                   (AND (EQ (CAR X)
                            Y)
                        (CDR X]
))(QUOTE PRETTYTYPE))

  (ADDTOVAR SYSPROPS RECORD RCROPS RECDEFAULT)
  (ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
  (ADDTOVAR CLISPRETTYWORDS create CREATE USING using)
  (ADDTOVAR CLISPWORDS CREATE create USING using)
  [ADDTOVAR PRETTYMACROS
            (RECORDS
              X
              (E (MAPC (QUOTE X)
                       (FUNCTION (LAMBDA
                                   (Z)
                                   (PRINT (LIST (QUOTE RECORD)
                                                Z
                                                (GETP Z (QUOTE RECORD]
  (ADDTOVAR GLOBALVARS CRLIST USERRECORDS CHANGEDRECLST 
            RECORDWORDSSPLST)
  (RPAQ CHANGEDRECLST NIL)
  (RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
          (CDR CADR CDDR CDR NIL)
          (CDDDDR NIL NIL CDR CDDDR)
          (CADDDR NIL NIL CAR CDDDR)
          (CDDDR CADDDR CDDDDR CDR CDDR)
          (CDADDR NIL NIL CDR CADDR)
          (CAADDR NIL NIL CAR CADDR)
          (CADDR CAADDR CDADDR CAR CDDR)
          (CDDR CADDR CDDDR CDR CDR)
          (CDDADR NIL NIL CDR CDADR)
          (CADADR NIL NIL CAR CDADR)
          (CDADR CADADR CDDADR CDR CADR)
          (CDAADR NIL NIL CDR CAADR)
          (CAAADR NIL NIL CAR CAADR)
          (CAADR CAAADR CDAADR CAR CADR)
          (CADR CAADR CDADR CAR CDR)
          (CDDDAR NIL NIL CDR CDDAR)
          (CADDAR NIL NIL CAR CDDAR)
          (CDDAR CADDAR CDDDAR CDR CDAR)
          (CDADAR NIL NIL CDR CADAR)
          (CAADAR NIL NIL CAR CADAR)
          (CADAR CAADAR CDADAR CAR CDAR)
          (CDAR CADAR CDDAR CDR CAR)
          (CDDAAR NIL NIL CDR CDAAR)
          (CADAAR NIL NIL CAR CDAAR)
          (CDAAR CADAAR CDDAAR CDR CAAR)
          (CDAAAR NIL NIL CDR CAAAR)
          (CAAAAR NIL NIL CAR CAAAR)
          (CAAAR CAAAAR CDAAAR CAR CAAR)
          (CAAR CAAAR CDAAR CAR CAR)))
  (RPAQ USERRECORDS NIL)
  (RPAQ DWIMUSERFN T)
  (RPAQQ RECORDWORDSSPLST (CREATE create USING using))
(DECLARE
  (BLOCK: MAKERPLAC MAKERPLAC CLISPLOOKUP)
  (BLOCK: CREATEBLOCK RECCOMPOSE0 RECCOMPOSE1 FIELDSIN RECCOMPOSE2 
          RECCOMPOSE4 'CAR 'CDR 'CONS (ENTRIES RECCOMPOSE0)
          (LOCALFREEVARS L FROMVAR))
  (BLOCK: RECORDBLOCK RECORD TYPERECORD RECDO /PUTDTST MAKECROPFN1
          (ENTRIES RECORD TYPERECORD)
          (BLKAPPLYFNS RECORD))
)STOP